{---------------------------------------------------------

  Jan van Eijck, november 2005 

  modified october 2010

 --------------------------------------------------------}

module Sudoku2

where 

import List

type Row    = Int 
type Column = Int 
type Value  = Int
type Grid   = [[Value]]

positions, values :: [Int]
positions = [1..9]
values    = [1..9] 

blocks :: [[Int]]
blocks = [[1..3],[4..6],[7..9]]

-- pick the block of a position
bl :: Int -> [Int]
bl x = concat $ filter (elem x) blocks 
   
showDgt :: Value -> String
showDgt 0 = " "
showDgt d = show d

showRow :: [Value] -> IO()
showRow [a1,a2,a3,a4,a5,a6,a7,a8,a9] = 
 do  putChar '|'         ; putChar ' '
     putStr (showDgt a1) ; putChar ' '
     putStr (showDgt a2) ; putChar ' '
     putStr (showDgt a3) ; putChar ' '
     putChar '|'         ; putChar ' '
     putStr (showDgt a4) ; putChar ' '
     putStr (showDgt a5) ; putChar ' '
     putStr (showDgt a6) ; putChar ' '
     putChar '|'         ; putChar ' '
     putStr (showDgt a7) ; putChar ' '
     putStr (showDgt a8) ; putChar ' '
     putStr (showDgt a9) ; putChar ' '
     putChar '|'
     putChar '\n'

showGrid :: Grid -> IO()
showGrid [as,bs,cs,ds,es,fs,gs,hs,is] =
 do putStrLn ("+-------+-------+-------+")
    showRow as; showRow bs; showRow cs
    putStrLn ("+-------+-------+-------+")
    showRow ds; showRow es; showRow fs
    putStrLn ("+-------+-------+-------+")
    showRow gs; showRow hs; showRow is
    putStrLn ("+-------+-------+-------+")

-- define a sudoku as a function from positions to values

type Sudoku = (Row,Column) -> Value

sud2grid :: Sudoku -> Grid
sud2grid s = [ [ s (r,c) | c <- [1..9] ] | r <- [1..9] ] 

showSudoku :: Sudoku -> IO()
showSudoku = showGrid . sud2grid

grid2sud :: Grid -> Sudoku
grid2sud gr = \ (r,c) -> pos gr (r,c) 
  where 
  pos :: [[a]] -> (Row,Column) -> a 
  pos gr (r,c) = (gr !! (r-1)) !! (c-1)

-- free values = available values at open slot positions 

freeInSeq :: [Value] -> [Value]
freeInSeq seq = values \\ seq 

freeInRow :: Sudoku -> Row -> [Value]
freeInRow s r = freeInSeq [ s (r,i) | i <- positions  ]

freeInColumn :: Sudoku -> Column -> [Value]
freeInColumn s c = freeInSeq [ s (i,c) | i <- positions ]

subGrid :: Sudoku -> (Row,Column) -> [Value]
subGrid s (r,c) = [ s (r',c') | r' <- bl r, c' <- bl c ]

freeInSubgrid :: Sudoku -> (Row,Column) -> [Value]
freeInSubgrid s (r,c) = freeInSeq (subGrid s (r,c))

freeAtPos :: Sudoku -> (Row,Column) -> [Value]
freeAtPos s (r,c) = (freeInRow s r) 
                      `intersect` (freeInColumn s c) 
                      `intersect` (freeInSubgrid s (r,c)) 

allDifferent :: Eq a => [a] -> Bool
allDifferent xs = nub xs == xs

-- check for consistency of a partial sudoku: 
-- check the rows, colums and subgrids

rowConsistent :: Sudoku -> Row -> Bool
rowConsistent s r = allDifferent vs where 
   vs = filter (/= 0) [ s (r,i) | i <- positions ]

colConsistent :: Sudoku -> Column -> Bool
colConsistent s c = allDifferent vs where 
   vs = filter (/= 0) [ s (i,c) | i <- positions ]

subgridConsistent :: Sudoku -> (Row,Column) -> Bool
subgridConsistent s (r,c) = allDifferent vs where 
   vs = filter (/= 0) (subGrid s (r,c))

consistent :: Sudoku -> Bool
consistent s = and $
               [ rowConsistent s r |  r <- positions ]
                ++
               [ colConsistent s c |  c <- positions ]
                ++
               [ subgridConsistent s (r,c) | r <- [1,4,7], c <- [1,4,7]]

-- Extend a sudoku by filling in a value in a new position 
extend :: Sudoku -> (Row,Column) -> Value -> Sudoku
extend s (r,c) v (i,j) | (i,j) == (r,c) = v
                       | otherwise      = s (i,j)

{------------------------------------------------------------
The search process 
-------------------------------------------------------------}

-- Type of nodes in the search tree: nodes are pairs consisting
-- of a sudoku and the list of all empty positions in it, 
-- together with possible values (according to the constraints 
-- imposed by the sudoku)

type Constraint = (Row,Column,[Value])
type Node = (Sudoku,[Constraint])

showNode :: Node -> IO()
showNode = showSudoku . fst

-- A sudoku is solved if there are no more empty slots. 

solved  :: Node -> Bool
solved = null . snd

-- The successors of a node are the nodes where the sudoku gets 
-- extended at the next empty slot position on the list. 

extendNode :: Node -> Constraint -> [Node]
extendNode (s,constraints) (r,c,vs) = 
   [(extend s (r,c) v, 
     sortBy length3rd $ prune (r,c,v) constraints) | v <- vs ]

length3rd :: (a,b,[c]) -> (a,b,[c]) -> Ordering
length3rd (_,_,zs) (_,_,zs') = compare (length zs) (length zs')

-- prune values that are no longer possible from constraint list
prune :: (Row,Column,Value) -> [Constraint] -> [Constraint]
prune _ [] = []
prune (r,c,v) ((x,y,zs):rest)
  | r == x = (x,y,zs\\[v]) : prune (r,c,v) rest
  | c == y = (x,y,zs\\[v]) : prune (r,c,v) rest
  | sameblock (r,c) (x,y) = (x,y,zs\\[v]) : prune (r,c,v) rest
  | otherwise = (x,y,zs) : prune (r,c,v) rest

sameblock :: (Row,Column) -> (Row,Column) -> Bool
sameblock (r,c) (x,y) = bl r == bl x && bl c == bl y 

succNode :: Node -> [Node]
succNode (s,[]) = []
succNode (s,p:ps) = extendNode (s,ps) p 

-- Initialisation: success is indicated by return of a unit node [n]. 

initNode :: Grid -> [Node]
initNode gr = let s = grid2sud gr in 
              if (not . consistent) s then [] 
              else [(s, constraints s)]

openPositions :: Sudoku -> [(Row,Column)]
openPositions s = [ (r,c) | r <- positions,  
                            c <- positions, s (r,c) == 0 ]

constraints :: Sudoku -> [Constraint] 
constraints s = sortBy length3rd 
    [(r,c, freeAtPos s (r,c)) | (r,c) <- openPositions s ]

-- The depth first search algorithm is completely standard. 
-- The goal property is used to end the search. 
 
search :: (node -> [node]) -> (node -> Bool) -> [node] -> [node]
search succ goal [] = []
search succ goal (x:xs) | goal x    = x : search succ goal xs
                        | otherwise = search succ goal ((succ x) ++ xs)

-- We solve by pursuing the search. 

solveNs :: [Node] -> [Node]
solveNs = search succNode solved 

-- Solving and showing the results 

solveAndShow :: Grid -> IO[()]
solveAndShow gr = sequence $ fmap showNode (solveNs $ initNode gr)

solveShowNs :: [Node] -> IO[()]
solveShowNs ns = sequence $ fmap showNode (solveNs ns)


-- examples

example1 :: Grid
example1 = [[5,3,0,0,7,0,0,0,0],
            [6,0,0,1,9,5,0,0,0],
            [0,9,8,0,0,0,0,6,0],
            [8,0,0,0,6,0,0,0,3],
            [4,0,0,8,0,3,0,0,1],
            [7,0,0,0,2,0,0,0,6],
            [0,6,0,0,0,0,2,8,0],
            [0,0,0,4,1,9,0,0,5],
            [0,0,0,0,8,0,0,7,9]]

example2 :: Grid
example2 = [[0,3,0,0,7,0,0,0,0],
            [6,0,0,1,9,5,0,0,0],
            [0,9,8,0,0,0,0,6,0],
            [8,0,0,0,6,0,0,0,3],
            [4,0,0,8,0,3,0,0,1],
            [7,0,0,0,2,0,0,0,6],
            [0,6,0,0,0,0,2,8,0],
            [0,0,0,4,1,9,0,0,5],
            [0,0,0,0,8,0,0,7,9]]

example3 :: Grid
example3 = [[1,0,0,0,3,0,5,0,4],
            [0,0,0,0,0,0,0,0,3],
            [0,0,2,0,0,5,0,9,8], 
            [0,0,9,0,0,0,0,3,0],
            [2,0,0,0,0,0,0,0,7],
            [8,0,3,0,9,1,0,6,0],
            [0,5,1,4,7,0,0,0,0],
            [0,0,0,3,0,0,0,0,0],
            [0,4,0,0,0,9,7,0,0]]

example4 :: Grid
example4 = [[1,2,3,4,5,6,7,8,9],
            [2,0,0,0,0,0,0,0,0],
            [3,0,0,0,0,0,0,0,0],
            [4,0,0,0,0,0,0,0,0],
            [5,0,0,0,0,0,0,0,0],
            [6,0,0,0,0,0,0,0,0],
            [7,0,0,0,0,0,0,0,0],
            [8,0,0,0,0,0,0,0,0],
            [9,0,0,0,0,0,0,0,0]]

example5 :: Grid
example5 = [[0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0],
            [0,0,0,0,0,0,0,0,0]]

pers14okt2010 :: Grid
pers14okt2010 = [[5,0,8,7,0,0,9,0,0],
                 [3,0,0,4,0,6,0,0,0],
                 [0,0,9,0,5,0,0,3,4],
                 [0,0,0,8,6,0,0,4,5],
                 [0,0,0,9,7,0,8,2,0],
                 [0,3,0,0,0,1,0,0,6],
                 [0,1,0,2,0,0,6,0,0],
                 [7,0,5,0,0,9,0,0,0],
                 [0,0,2,0,0,0,0,8,7]]
